(defun simplify-no-redundant-checks (xexpr) 
  (if (atom xexpr) 
      xexpr 
      (let ((op (first xexpr)) 
            (z (second xexpr)) 
            (y (third xexpr))) 
        (let* ((f (simplify-no-redundant-checks z)) 
               (g (simplify-no-redundant-checks y)) 
               (nf (numberp f)) 
               (ng (numberp g))) 
          (tagbody 
           START 
             (if (eq '+ op) (go OPTIMIZE-PLUS) (go TEST-MULTIPLY)) 
           OPTIMIZE-PLUS 
             (when (and nf ng) (return-from simplify-no-redundant-checks (+ 
f g))) 
           TEST-PLUS-ZEROS 
             (when (eql f 0) (return-from simplify-no-redundant-checks g)) 
             (when (eql g 0) (return-from simplify-no-redundant-checks f)) 
             (go REARRANGE-EXPR) 
           TEST-MULTIPLY 
             (unless (eq '* op) (go REARRANGE-EXPR)) 
           OPTIMIZE-MULTIPLY 
             (when (and nf ng) (return-from simplify-no-redundant-checks (* 
f g))) 
           TEST-MULTIPLY-ZEROS-AND-ONES 
             (when (or (eql f 0) (eql g 0)) (return-from 
simplify-no-redundant-checks 0)) 
             (when (eql f 1) (return-from simplify-no-redundant-checks g)) 
             (when (eql g 1) (return-from simplify-no-redundant-checks f)) 
           REARRANGE-EXPR 
             (when (and (listp g) (eq op (first g))) 
               (let ((op2 (first g)) 
                     (u (second g)) 
                     (v (third g))) 
                 (declare (ignore op2)) 
                 (return-from simplify-no-redundant-checks 
                   (simplify-no-redundant-checks (list op (list op f u) 
v))))) 
           MAYBE-CONS-EXPR 
             (if (and (eq f z) (eq g y)) 
                 (return-from simplify-no-redundant-checks xexpr) 
                 (return-from simplify-no-redundant-checks (list op f 
g)))))))) 


(defun tt (N) (gc) (time (test N)))

(setq *expr* '(* X (+ (+ (* 12 0) (+ 23 8)) Y)))

(defun test (N)
    (COND ((ZEROP N) 0)
         (T (simplify-no-redundant-checks *expr*) (test (1- N)))))
  
(mapc 'compile '(tt test simplify-no-redundant-checks))




